noDaemonRunning = addCheck NoDaemonRunning $ whenM (isJust <$> daemonpid) $
giveup "You cannot run this command while git-annex watch or git-annex assistant is running."
where
- daemonpid = liftIO . checkDaemon . fromRawFilePath
- =<< fromRepo gitAnnexPidFile
+ daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile
dontCheck :: CommandCheck -> Command -> Command
dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
, usesLocationLog = False
}
-start :: Bool -> SeekInput -> RawFilePath -> Key -> CommandStart
+start :: Bool -> SeekInput -> OsPath -> Key -> CommandStart
start fast si file key =
starting "unannex" (mkActionItem (key, file)) si $
perform fast file key
-perform :: Bool -> RawFilePath -> Key -> CommandPerform
+perform :: Bool -> OsPath -> Key -> CommandPerform
perform fast file key = do
Annex.Queue.addCommand [] "rm"
[ Param "--cached"
, Param "--quiet"
, Param "--"
]
- [fromRawFilePath file]
+ [fromOsPath file]
isAnnexLink file >>= \case
-- If the file is locked, it needs to be replaced with
-- the content from the annex. Note that it's possible
maybe noop Database.Keys.removeInodeCache
=<< withTSDelta (liftIO . genInodeCache file)
-cleanup :: Bool -> RawFilePath -> Key -> CommandCleanup
+cleanup :: Bool -> OsPath -> Key -> CommandCleanup
cleanup fast file key = do
- liftIO $ removeFile (fromRawFilePath file)
+ liftIO $ removeFile file
src <- calcRepo (gitAnnexLocation key)
ifM (pure fast <||> Annex.getRead Annex.fast)
( do
-- already have other hard links pointing at it. This
-- avoids unannexing (and uninit) ending up hard
-- linking files together, which would be surprising.
- s <- liftIO $ R.getFileStatus src
+ s <- liftIO $ R.getFileStatus (fromOsPath src)
if linkCount s > 1
then copyfrom src
else hardlinkfrom src
)
where
copyfrom src =
- thawContent file `after` liftIO
- (copyFileExternal CopyAllMetaData
- (fromRawFilePath src)
- (fromRawFilePath file))
+ thawContent file `after`
+ liftIO (copyFileExternal CopyAllMetaData src file)
hardlinkfrom src =
-- creating a hard link could fall; fall back to copying
- ifM (liftIO $ catchBoolIO $ R.createLink src file >> return True)
+ ifM (liftIO $ tryhardlink src file)
( return True
, copyfrom src
)
+ tryhardlink src dest = catchBoolIO $ do
+ R.createLink (fromOsPath src) (fromOsPath dest)
+ return True
import qualified Git.LsFiles as LsFiles
import qualified Git.Command as Git
import qualified Git.Branch
-import qualified Utility.RawFilePath as R
cmd :: Command
cmd = notBareRepo $ withAnnexOptions [jsonOptions] $
seek ps = do
-- Safety first; avoid any undo that would touch files that are not
-- in the index.
- (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toRawFilePath ps)
+ (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toOsPath ps)
unless (null fs) $ do
qp <- coreQuotePath <$> Annex.getGitConfig
giveup $ decodeBS $ quote qp $
start :: FilePath -> CommandStart
start p = starting "undo" ai si $
- perform p
+ perform p'
where
- ai = ActionItemOther (Just (QuotedPath (toRawFilePath p)))
+ p' = toOsPath p
+ ai = ActionItemOther (Just (QuotedPath p'))
si = SeekInput [p]
-perform :: FilePath -> CommandPerform
+perform :: OsPath -> CommandPerform
perform p = do
g <- gitRepo
-- Get the reversed diff that needs to be applied to undo.
(diff, cleanup) <- inRepo $
- diffLog [Param "-R", Param "--", Param p]
- top <- inRepo $ toTopFilePath $ toRawFilePath p
+ diffLog [Param "-R", Param "--", Param (fromOsPath p)]
+ top <- inRepo $ toTopFilePath p
let diff' = filter (`isDiffOf` top) diff
liftIO $ streamUpdateIndex g (map stageDiffTreeItem diff')
forM_ removals $ \di -> do
f <- mkrel di
- liftIO $ removeWhenExistsWith R.removeLink f
+ liftIO $ removeWhenExistsWith removeFile f
forM_ adds $ \di -> do
- f <- fromRawFilePath <$> mkrel di
+ f <- fromOsPath <$> mkrel di
inRepo $ Git.run [Param "checkout", Param "--", File f]
next $ liftIO cleanup
when (b == Just Annex.Branch.name) $ giveup $
"cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out"
top <- fromRepo Git.repoPath
- currdir <- liftIO R.getCurrentDirectory
+ currdir <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
giveup "can only run uninit from the top of the git repository"
{- git annex symlinks that are not checked into git could be left by an
- interrupted add. -}
-startCheckIncomplete :: Annex () -> RawFilePath -> Key -> CommandStart
+startCheckIncomplete :: Annex () -> OsPath -> Key -> CommandStart
startCheckIncomplete recordnotok file key =
starting "uninit check" (mkActionItem (file, key)) (SeekInput []) $ do
recordnotok
giveup $ unlines err
where
err =
- [ fromRawFilePath file ++ " points to annexed content, but is not checked into git."
+ [ fromOsPath file ++ " points to annexed content, but is not checked into git."
, "Perhaps this was left behind by an interrupted git annex add?"
, "Not continuing with uninit; either delete or git annex add the file and retry."
]
prepareRemoveAnnexDir annexdir
if null leftovers
then do
- liftIO $ removeDirectoryRecursive (fromRawFilePath annexdir)
+ liftIO $ removeDirectoryRecursive annexdir
next recordok
else giveup $ unlines
[ "Not fully uninitialized"
- , "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir
+ , "Some annexed data is still left in " ++ fromOsPath annexobjectdir
, "This may include deleted files, or old versions of modified files."
, ""
, "If you don't care about preserving the data, just delete the"
-
- Also closes sqlite databases that might be in the directory,
- to avoid later failure to write any cached changes to them. -}
-prepareRemoveAnnexDir :: RawFilePath -> Annex ()
+prepareRemoveAnnexDir :: OsPath -> Annex ()
prepareRemoveAnnexDir annexdir = do
Database.Keys.closeDb
liftIO $ prepareRemoveAnnexDir' annexdir
-prepareRemoveAnnexDir' :: RawFilePath -> IO ()
+prepareRemoveAnnexDir' :: OsPath -> IO ()
prepareRemoveAnnexDir' annexdir =
emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir)
>>= mapM_ (void . tryIO . allowWrite)
, go (k:c) ks
)
enoughlinks f = catchBoolIO $ do
- s <- R.getFileStatus f
+ s <- R.getFileStatus (fromOsPath f)
return $ linkCount s > 1
completeUnitialize :: CommandStart
, usesLocationLog = False
}
-start :: SeekInput -> RawFilePath -> Key -> CommandStart
+start :: SeekInput -> OsPath -> Key -> CommandStart
start si file key = ifM (isJust <$> isAnnexLink file)
( starting "unlock" ai si $ perform file key
, stop
where
ai = mkActionItem (key, AssociatedFile (Just file))
-perform :: RawFilePath -> Key -> CommandPerform
+perform :: OsPath -> Key -> CommandPerform
perform dest key = do
- destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest
+ destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath dest)
destic <- replaceWorkTreeFile dest $ \tmp -> do
ifM (inAnnex key)
( do
withTSDelta (liftIO . genInodeCache tmp)
next $ cleanup dest destic key destmode
-cleanup :: RawFilePath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup
+cleanup :: OsPath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup
cleanup dest destic key destmode = do
stagePointerFile dest destmode =<< hashPointerFile key
maybe noop (restagePointerFile (Restage True) dest) destic
maybeAddJSONField
((if null fileprefix then "unused" else fileprefix) ++ "-list")
(M.fromList $ map (\(n, k) -> (T.pack (show n), serializeKey k)) unusedlist)
- updateUnusedLog (toRawFilePath fileprefix) (M.fromList unusedlist)
+ updateUnusedLog (toOsPath fileprefix) (M.fromList unusedlist)
return $ c + length l
number :: Int -> [a] -> [(Int, a)]
{- Given an initial value, accumulates the value over each key
- referenced by files in the working tree. -}
-withKeysReferenced :: v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v
+withKeysReferenced :: v -> (Key -> OsPath -> v -> Annex v) -> Annex v
withKeysReferenced initial = withKeysReferenced' Nothing initial
{- Runs an action on each referenced key in the working tree. -}
calla k _ _ = a k
{- Folds an action over keys and files referenced in a particular directory. -}
-withKeysFilesReferencedIn :: FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v
+withKeysFilesReferencedIn :: OsPath -> v -> (Key -> OsPath -> v -> Annex v) -> Annex v
withKeysFilesReferencedIn = withKeysReferenced' . Just
-withKeysReferenced' :: Maybe FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v
+withKeysReferenced' :: Maybe OsPath -> v -> (Key -> OsPath -> v -> Annex v) -> Annex v
withKeysReferenced' mdir initial a = do
(files, clean) <- getfiles
r <- go initial files
top <- fromRepo Git.repoPath
inRepo $ LsFiles.allFiles [] [top]
)
- Just dir -> inRepo $ LsFiles.inRepo [] [toRawFilePath dir]
+ Just dir -> inRepo $ LsFiles.inRepo [] [dir]
go v [] = return v
go v (f:fs) = do
mk <- lookupKey f
withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CmdParams -> CommandSeek
withUnusedMaps a params = do
- unused <- readUnusedMap ""
- unusedbad <- readUnusedMap "bad"
- unusedtmp <- readUnusedMap "tmp"
+ unused <- readUnusedMap (literalOsPath "")
+ unusedbad <- readUnusedMap (literalOsPath "bad")
+ unusedtmp <- readUnusedMap (literalOsPath "tmp")
let m = unused `M.union` unusedbad `M.union` unusedtmp
let unusedmaps = UnusedMaps unused unusedbad unusedtmp
commandActions $ map (a unusedmaps) $ concatMap (unusedSpec m) params
import Remote
import Git.Types (fromConfigKey, fromConfigValue)
import Utility.DataUnits
-import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
cmd :: Command
start :: CommandStart
start = do
f <- fromRepo gitAnnexTmpCfgFile
- let f' = fromRawFilePath f
createAnnexDirectory $ parentDir f
cfg <- getCfg
descs <- uuidDescriptions
- liftIO $ writeFile f' $ genCfg cfg descs
- vicfg cfg f'
+ liftIO $ writeFile (fromOsPath f) $ genCfg cfg descs
+ vicfg cfg f
stop
-vicfg :: Cfg -> FilePath -> Annex ()
+vicfg :: Cfg -> OsPath -> Annex ()
vicfg curcfg f = do
vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR"
- -- Allow EDITOR to be processed by the shell, so it can contain options.
- unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
+ unlessM (liftIO $ boolSystem "sh" (shparams vi)) $
giveup $ vi ++ " exited nonzero; aborting"
r <- liftIO $ parseCfg (defCfg curcfg)
. map decodeBS
. fileLines'
- <$> F.readFile' (toOsPath (toRawFilePath f))
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
+ <$> F.readFile' f
+ liftIO $ removeWhenExistsWith removeFile f
case r of
Left s -> do
- liftIO $ writeFile f s
+ liftIO $ writeFile (fromOsPath f) s
vicfg curcfg f
Right newcfg -> setCfg curcfg newcfg
+ where
+ -- Allow EDITOR to be processed by the shell,
+ -- so it can contain options.
+ shparams editor =
+ [ Param "-c"
+ , Param $ unwords [editor, shellEscape (fromOsPath f)]
+ ]
data Cfg = Cfg
{ cfgTrustMap :: M.Map UUID (Down TrustLevel)
import Types.AdjustedBranch
import Annex.AdjustedBranch.Name
-import qualified System.FilePath.ByteString as P
-
cmd :: Command
cmd = notBareRepo $
command "view" SectionMetaData "enter a view branch"
forM_ l (removeemptydir top)
liftIO $ void cleanup
unlessM (liftIO $ doesDirectoryExist here) $ do
- showLongNote $ UnquotedString $ cwdmissing (fromRawFilePath top)
+ showLongNote $ UnquotedString $ cwdmissing (fromOsPath top)
return ok
where
removeemptydir top d = do
p <- inRepo $ toTopFilePath d
- liftIO $ tryIO $ removeDirectory $
- fromRawFilePath $ (top P.</> getTopFilePath p)
+ liftIO $ tryIO $ removeDirectory $ top </> getTopFilePath p
cwdmissing top = unlines
[ "This view does not include the subdirectory you are currently in."
, "Perhaps you should: cd " ++ top
display key (descBranchFilePath (BranchFilePath r tf))
return True
-searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Annex Bool) -> Annex Bool
+searchLog :: Key -> [CommandParam] -> (S.ByteString -> [OsPath] -> Annex Bool) -> Annex Bool
searchLog key ps a = do
(output, cleanup) <- Annex.inRepo $ Git.Command.pipeNullSplit ps'
found <- case output of
-- so a regexp is used. Since annex pointer files
-- may contain a newline followed by perhaps something
-- else, that is also matched.
- , Param ("-G" ++ escapeRegexp (fromRawFilePath (keyFile key)) ++ "($|\n)")
+ , Param ("-G" ++ escapeRegexp (fromOsPath (keyFile key)) ++ "($|\n)")
-- Skip commits where the file was deleted,
-- only find those where it was added or modified.
, Param "--diff-filter=ACMRTUX"
instance FromConfigValue String where
fromConfigValue = decodeBS . fromConfigValue
+instance FromConfigValue OsPath where
+ fromConfigValue v = toOsPath (fromConfigValue v :: S.ByteString)
+
instance Show ConfigValue where
show = fromConfigValue
import qualified Utility.Metered
import qualified Utility.HumanTime
import qualified Command.Uninit
+import qualified Utility.OsString as OS
-- Run a process. The output and stderr is captured, and is only
-- displayed if the process does not return the expected value.
let params' = if debug
then "--debug":params
else params
- testProcess pp (command:params') environ expectedret expectedtranscript faildesc
+ testProcess (fromOsPath pp) (command:params') environ
+ expectedret expectedtranscript faildesc
{- Runs git-annex and returns its standard output. -}
git_annex_output :: String -> [String] -> IO String
git_annex_output command params = do
pp <- Annex.Path.programPath
- Utility.Process.readProcess pp (command:params)
+ Utility.Process.readProcess (fromOsPath pp) (command:params)
git_annex_expectoutput :: String -> [String] -> [String] -> Assertion
git_annex_expectoutput command params expected = do
let v = Git.Types.ConfigValue (toRawFilePath "/dev/null")
origindir <- absPath . Git.Types.fromConfigValue
=<< annexeval (Config.getConfig k v)
- let originurl = "localhost:" ++ fromRawFilePath origindir
+ let originurl = "localhost:" ++ fromOsPath origindir
git "config" [config, originurl] "git config failed"
a
where
checkRepo :: Types.Annex a -> FilePath -> IO a
checkRepo getval d = do
- s <- Annex.new =<< Git.Construct.fromPath (toRawFilePath d)
+ s <- Annex.new =<< Git.Construct.fromPath (toOsPath d)
Annex.eval s $
getval `finally` Annex.Action.stopCoProcesses
-- any type of error and change back to currdir before
-- rethrowing.
r <- bracket_
- (setCurrentDirectory path)
+ (setCurrentDirectory (toOsPath path))
(setCurrentDirectory currdir)
(tryNonAsync a)
case r of
ensuredir :: FilePath -> IO ()
ensuredir d = do
- e <- doesDirectoryExist d
+ let d' = toOsPath d
+ e <- doesDirectoryExist d'
unless e $
- createDirectory d
+ createDirectory d'
{- This is the only place in the test suite that can use setEnv.
- Using it elsewhere can conflict with tasty's use of getEnv, which can
- happen concurrently with a test case running, and would be a problem
- since setEnv is not thread safe. This is run before tasty. -}
setTestEnv :: IO a -> IO a
-setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do
- tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome)
+setTestEnv a = Utility.Tmp.Dir.withTmpDir (literalOsPath "testhome") $ \tmphome -> do
+ tmphomeabs <- fromOsPath <$> absPath tmphome
{- Prevent global git configs from affecting the test suite. -}
Utility.Env.Set.setEnv "HOME" tmphomeabs True
Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True
-- Ensure that the same git-annex binary that is running
-- git-annex test is at the front of the PATH.
- p <- Utility.Env.getEnvDefault "PATH" ""
pp <- Annex.Path.programPath
- Utility.Env.Set.setEnv "PATH" (takeDirectory pp ++ [searchPathSeparator] ++ p) True
+ p <- Utility.Env.getEnvDefault "PATH" ""
+ let p' = fromOsPath $
+ takeDirectory pp <> OS.singleton searchPathSeparator <> toOsPath p
+ Utility.Env.Set.setEnv "PATH" p' True
-- Avoid git complaining if it cannot determine the user's
-- email address, or exploding if it doesn't know the user's name.
-- Record top directory.
currdir <- getCurrentDirectory
- Utility.Env.Set.setEnv "TOPDIR" currdir True
+ Utility.Env.Set.setEnv "TOPDIR" (fromOsPath currdir) True
a
removeDirectoryForCleanup :: FilePath -> IO ()
-removeDirectoryForCleanup = removePathForcibly
+removeDirectoryForCleanup = removePathForcibly . toOsPath
cleanup :: FilePath -> IO ()
-cleanup dir = whenM (doesDirectoryExist dir) $ do
- Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath dir)
+cleanup dir = whenM (doesDirectoryExist (toOsPath dir)) $ do
+ Command.Uninit.prepareRemoveAnnexDir' (toOsPath dir)
-- This can fail if files in the directory are still open by a
-- subprocess.
void $ tryIO $ removeDirectoryForCleanup dir
finalCleanup :: IO ()
-finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
- Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath tmpdir)
+finalCleanup = whenM (doesDirectoryExist (toOsPath tmpdir)) $ do
+ Command.Uninit.prepareRemoveAnnexDir' (toOsPath tmpdir)
catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do
print e
putStrLn "sleeping 10 seconds and will retry directory cleanup"
Utility.ThreadScheduler.threadDelaySeconds $
Utility.ThreadScheduler.Seconds 10
- whenM (doesDirectoryExist tmpdir) $
+ whenM (doesDirectoryExist (toOsPath tmpdir)) $
removeDirectoryForCleanup tmpdir
checklink :: FilePath -> Assertion
checklink f = ifM (annexeval Config.crippledFileSystem)
- ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toRawFilePath f)))
+ ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toOsPath f)))
@? f ++ " is not a (crippled) symlink"
, do
s <- R.getSymbolicLinkStatus (toRawFilePath f)
checklocationlog :: FilePath -> Bool -> Assertion
checklocationlog f expected = do
thisuuid <- annexeval Annex.UUID.getUUID
- r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f)
+ r <- annexeval $ Annex.WorkTree.lookupKey (toOsPath f)
case r of
Just k -> do
uuids <- annexeval $ Remote.keyLocations k
checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do
b <- annexeval $ maybe (return Nothing) (Backend.getBackend file)
- =<< Annex.WorkTree.lookupKey (toRawFilePath file)
+ =<< Annex.WorkTree.lookupKey (toOsPath file)
assertEqual ("backend for " ++ file) (Just expected) b
checkispointerfile :: FilePath -> Assertion
-checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toRawFilePath f)) $
+checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toOsPath f)) $
assertFailure $ f ++ " is not a pointer file"
inlocationlog :: FilePath -> Assertion
unannexed_in_git :: FilePath -> Assertion
unannexed_in_git f = do
unannexed f
- r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f)
+ r <- annexeval $ Annex.WorkTree.lookupKey (toOsPath f)
case r of
Just _k -> assertFailure $ f ++ " is annexed in git"
Nothing -> return ()
where
go n = do
let d = "main" ++ show n
- ifM (doesDirectoryExist d)
+ ifM (doesDirectoryExist (toOsPath d))
( go $ n + 1
, do
- createDirectory d
+ createDirectory (toOsPath d)
return d
)
where
go n = do
let d = "tmprepo" ++ show n
- ifM (doesDirectoryExist d)
+ ifM (doesDirectoryExist (toOsPath d))
( go $ n + 1
, return d
)
writecontent f c = go (10000000 :: Integer)
where
go ticsleft = do
- oldmtime <- catchMaybeIO $ getModificationTime f
+ oldmtime <- catchMaybeIO $ getModificationTime (toOsPath f)
writeFile f c
- newmtime <- getModificationTime f
+ newmtime <- getModificationTime (toOsPath f)
if Just newmtime == oldmtime
then do
threadDelay 100000
Nothing -> error "internal"
where
ks = Types.KeySource.KeySource
- { Types.KeySource.keyFilename = toRawFilePath f
- , Types.KeySource.contentLocation = toRawFilePath f
+ { Types.KeySource.keyFilename = toOsPath f
+ , Types.KeySource.contentLocation = toOsPath f
, Types.KeySource.inodeCache = Nothing
}
go Nothing = summarizeresults $ withConcurrentOutput $ do
ensuredir tmpdir
crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'
- (toRawFilePath tmpdir)
+ (toOsPath tmpdir)
Nothing Nothing False
adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
let ts = mkts numparts crippledfilesystem adjustedbranchok opts
mapM_ (hPutStrLn stderr) warnings
environ <- Utility.Env.getEnvironment
args <- getArgs
- pp <- Annex.Path.programPath
+ pp <- fromOsPath <$> Annex.Path.programPath
termcolor <- hSupportsANSIColor stdout
let ps = if useColor (lookupOption tastyopts) termcolor
then "--color=always":args
else "--color=never":args
let runone n = do
- let subdir = tmpdir </> show n
+ let subdir = fromOsPath $ toOsPath tmpdir </> toOsPath (show n)
ensuredir subdir
let p = (proc pp ps)
{ env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ)
- run for an entire year and so predate the v9 upgrade. -}
assistantrunning = do
pidfile <- fromRepo gitAnnexPidFile
- isJust <$> liftIO (checkDaemon (fromOsPath pidfile))
+ isJust <$> liftIO (checkDaemon pidfile)
unsafeupgrade =
[ "Not upgrading from v9 to v10, because there may be git-annex"
- License: BSD-2-clause
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Utility.Daemon (
#else
import System.Win32.Process (terminateProcessById)
import Utility.LockFile
+import qualified Utility.OsString as OS
#endif
#ifndef mingw32_HOST_OS
- Instead, it runs the cmd with provided params, in the background,
- which the caller should arrange to run this again.
-}
-daemonize :: String -> [CommandParam] -> IO Fd -> Maybe FilePath -> Bool -> IO () -> IO ()
+daemonize :: String -> [CommandParam] -> IO Fd -> Maybe OsPath -> Bool -> IO () -> IO ()
daemonize cmd params openlogfd pidfile changedirectory a = do
maybe noop checkalreadyrunning pidfile
getEnv envvar >>= \case
{- To run an action that is normally daemonized in the foreground. -}
#ifndef mingw32_HOST_OS
-foreground :: IO Fd -> Maybe FilePath -> IO () -> IO ()
+foreground :: IO Fd -> Maybe OsPath -> IO () -> IO ()
foreground openlogfd pidfile a = do
#else
-foreground :: Maybe FilePath -> IO () -> IO ()
+foreground :: Maybe OsPath -> IO () -> IO ()
foreground pidfile a = do
#endif
maybe noop lockPidFile pidfile
-
- Writes the pid to the file, fully atomically.
- Fails if the pid file is already locked by another process. -}
-lockPidFile :: FilePath -> IO ()
+lockPidFile :: OsPath -> IO ()
lockPidFile pidfile = do
#ifndef mingw32_HOST_OS
- fd <- openFdWithMode (toRawFilePath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags
+ fd <- openFdWithMode (fromOsPath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags
locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
- fd' <- openFdWithMode (toRawFilePath newfile) ReadWrite (Just stdFileMode) defaultFileFlags
+ fd' <- openFdWithMode (fromOsPath newfile) ReadWrite (Just stdFileMode) defaultFileFlags
{ trunc = True }
locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0)
case (locked, locked') of
_ -> do
_ <- fdWrite fd' =<< show <$> getPID
closeFd fd
- rename newfile pidfile
+ renameFile newfile pidfile
where
- newfile = pidfile ++ ".new"
+ newfile = pidfile <> literalOsPath ".new"
#else
{- Not atomic on Windows, oh well. -}
unlessM (isNothing <$> checkDaemon pidfile)
alreadyRunning
pid <- getPID
- writeFile pidfile (show pid)
+ writeFile (fromOsPath pidfile) (show pid)
lckfile <- winLockFile pid pidfile
- writeFile (fromRawFilePath lckfile) ""
+ writeFile (fromOsPath lckfile) ""
void $ lockExclusive lckfile
#endif
- is locked by the same process that is listed in the pid file.
-
- If it's running, returns its pid. -}
-checkDaemon :: FilePath -> IO (Maybe PID)
+checkDaemon :: OsPath -> IO (Maybe PID)
#ifndef mingw32_HOST_OS
checkDaemon pidfile = bracket setup cleanup go
where
setup = catchMaybeIO $
- openFdWithMode (toRawFilePath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags
+ openFdWithMode (fromOsPath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags
cleanup (Just fd) = closeFd fd
cleanup Nothing = return ()
go (Just fd) = catchDefaultIO Nothing $ do
locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
- p <- readish <$> readFile pidfile
+ p <- readish <$> readFile (fromOsPath pidfile)
return (check locked p)
go Nothing = return Nothing
check (Just (pid, _)) (Just pid')
| pid == pid' = Just pid
| otherwise = giveup $
- "stale pid in " ++ pidfile ++
+ "stale pid in " ++ fromOsPath pidfile ++
" (got " ++ show pid' ++
"; expected " ++ show pid ++ " )"
#else
checkDaemon pidfile = maybe (return Nothing) (check . readish)
- =<< catchMaybeIO (readFile pidfile)
+ =<< catchMaybeIO (readFile (fromOsPath pidfile))
where
check Nothing = return Nothing
check (Just pid) = do
- v <- lockShared =<< winLockFile pid pidfile
+ v <- lockShared =<< winLockFile pid (fromOsPath pidfile)
case v of
Just h -> do
dropLock h
#endif
{- Stops the daemon, safely. -}
-stopDaemon :: FilePath -> IO ()
+stopDaemon :: OsPath -> IO ()
stopDaemon pidfile = go =<< checkDaemon pidfile
where
go Nothing = noop
- when eg, restarting the daemon.
-}
#ifdef mingw32_HOST_OS
-winLockFile :: PID -> FilePath -> IO RawFilePath
+winLockFile :: PID -> OsPath -> IO OsPath
winLockFile pid pidfile = do
cleanstale
- return $ toRawFilePath $ prefix ++ show pid ++ suffix
+ return $ prefix <> toOsPath (show pid) <> suffix
where
- prefix = pidfile ++ "."
- suffix = ".lck"
+ prefix = pidfile <> literalOsPath "."
+ suffix = literalOsPath ".lck"
cleanstale = mapM_ (void . tryIO . removeFile) =<<
- (filter iswinlockfile . map fromRawFilePath <$> dirContents (parentDir (toRawFilePath pidfile)))
- iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
+ (filter iswinlockfile <$> dirContents (parentDir pidfile))
+ iswinlockfile f = suffix `OS.isSuffixOf` f && prefix `OS.isPrefixOf` f
#endif
projects / git-annex.git / commitdiff